home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istdc / ISTDC.MAC.f
Encoding:
Text File  |  1989-03-04  |  45.0 KB  |  1,648 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C
  5. C  ISTDC - DATA COMPARISON PROGRAM
  6. C          A TIE CONFORMING DATA COMPARISON TOOL GENERATED FROM THE
  7. C            'COMPARE' UTILITY CREATED AT BRADFORD UNIVERSITY
  8. C            BY PETER JEWELL AT THE UNIVERSITY OF BRADFORD.
  9. C
  10. C------------------------------------------------------------------------
  11. C
  12. C
  13.       PROGRAM ISTDC
  14. C
  15. C     .. Parameters ..
  16.       INTEGER LINLEN
  17.       PARAMETER (LINLEN=134)
  18.       CHARACTER SPACE, UPARW
  19.       PARAMETER (UPARW='^',SPACE=' ')
  20. C     ..
  21. C     .. Scalars in Common ..
  22.       INTEGER II1,II2,L1TOT,L2TOT,LEN1,LEN2,LT1,LT2,
  23.      +        NERROR
  24.       LOGICAL EXACT, VERBOS
  25.       CHARACTER*(LINLEN) A,B,LINE1,LINE2
  26. C     ..
  27. C     .. Arrays in Common ..
  28.       DOUBLE PRECISION T(3)
  29.       INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
  30. C     ..
  31. C     .. Local Scalars ..
  32.       REAL TT
  33.       INTEGER I,I1,I2,I2SV,K,K1,K2,KA,KB,KOUNT,LINERR,LNFLAG,LTOT,LTOT1,
  34.      +        LTOT2,MAXFWD,MISAL,N,TEST,TEMP1,TEMP2,OFFSET,TMP
  35.       LOGICAL ENDF1,ENDF2,FIRST,HEADER,NUMBER,OK,PRINT,SPNULL,MATCH,
  36.      +        FOLD
  37.       CHARACTER S,MARKER*4,NAME*7,VAL*7,POINT1* (LINLEN),
  38.      +          POINT2* (LINLEN)
  39. C     ..
  40. C     .. Local Arrays ..
  41.       INTEGER MIS1(3),MIS2(3), BUFFER(134), STDPTH(81),
  42.      +        OUTPTH(81), CMPPTH(81)
  43. C     ..
  44. C     .. External Functions ..
  45.       INTEGER CREATE,GETARG,OPEN,READS
  46.       LOGICAL SAME
  47.       EXTERNAL CREATE,GETARG,OPEN,READS,SAME
  48. C     ..
  49. C     .. External Subroutines ..
  50.       EXTERNAL CHKNUM,ERROR,LISTF2,PUTCH,PUTLIN,SEARCH,SHRINK,ZCHOUT,
  51.      +         ZINIT,ZMESS,ZPTINT,ZPTMES,ZPUTCH,ZQUIT
  52. C     ..
  53. C     .. Intrinsic Functions ..
  54.       INTRINSIC ABS,MAX,SIGN
  55. C     ..
  56. C     .. Common blocks ..
  57.       COMMON LEN1,LEN2,L1TOT,L2TOT,KEY1,KEY2,LT1,LT2
  58.       COMMON /B1/LINE1,LINE2,A,B
  59.       COMMON /B2/KEYA,KEYB
  60.       COMMON /ONLNE/II1,II2,NERROR,EXACT
  61.       COMMON /TOLS/T
  62.       COMMON /OPTSC/ MARKER
  63.       COMMON /OPTSI/ MAXFWD, SPNULL, HEADER, FOLD, VERBOS
  64. C---------------------------------------------------------
  65. C    TOOLPACK/1    Release: 3.1
  66. C---------------------------------------------------------
  67. C
  68. C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
  69. C  PROVIDE PORTABLE RECORD BACKSPACING.
  70. C
  71. C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
  72. C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
  73. C             FROM A READS CALL FOR EACH FILE
  74. C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
  75. C             EACH FILE
  76. C  SAVLIN     SAVED LINES FOR EACH FILE
  77. C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
  78. C  INFO(2..)  THE LINE NUMBER
  79. C
  80.       INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
  81.       COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
  82.       CHARACTER*134  SAVLIN(100, 2)
  83.       COMMON /STACKC/ SAVLIN
  84.       SAVE
  85. C     ..
  86.  
  87.       DATA (MIS1(I),I=1,3)/-2,-2,-2/
  88.       DATA (MIS2(I),I=1,3)/-2,-2,-2/
  89. C
  90. C  READING AND ANALYSING PARAMETERS
  91. C     ..
  92.       CALL ZINIT
  93.  
  94.       IF(GETARG(1, STDPTH, 81) .EQ. -100) CALL NAMES(1, STDPTH)
  95.       IF(GETARG(2, CMPPTH, 81) .EQ. -100) CALL NAMES(2, CMPPTH)
  96.       IF(GETARG(3, OUTPTH, 81) .EQ. -100) CALL NAMES(3, OUTPTH)
  97.       FDS(1) = OPEN(STDPTH, 0)
  98.       FDS(2) = OPEN(CMPPTH, 0)
  99.       FDS(3) = CREATE(OUTPTH, 1)
  100.       DO 10 I = 1, 3
  101.         IF(FDS(I) .EQ. -1) CALL ERROR('FILE ERROR.')
  102.    10 CONTINUE
  103.       DO 11 I = 4, 10
  104.         IF(GETARG(I, BUFFER, 132) .NE. -100) CALL IDOPS(BUFFER)
  105.    11 CONTINUE
  106. C
  107.       IF (HEADER) THEN
  108.         CALL ZMESS('------- DATA COMPARISON PROGRAM --------.', FDS(3))
  109.         CALL PUTCH(10, FDS(3))
  110.         CALL ZCHOUT('STANDARD FILE  : .', FDS(3))
  111.         CALL ZPTMES(STDPTH, FDS(3))
  112.         CALL ZCHOUT('COMPARISON FILE: .', FDS(3))
  113.         CALL ZPTMES(CMPPTH, FDS(3))
  114.         CALL PUTCH(10, FDS(3))
  115.  
  116.         IF (SPNULL) THEN
  117.           CALL ZMESS(' - SPACES ARE BEING IGNORED.', FDS(3))
  118.         ELSE
  119.           CALL ZMESS(' - SPACES ARE SIGNIFICANT.', FDS(3))
  120.         END IF
  121.         IF (FOLD) THEN
  122.           CALL ZMESS(' - CHARACTER CASE IS BEING IGNORED.', FDS(3))
  123.         ELSE
  124.           CALL ZMESS(' - CHARACTER CASE IS SIGNIFICANT.', FDS(3))
  125.         END IF
  126.         IF (EXACT) THEN
  127.           CALL ZMESS(' - NUMERIC VALUES MUST MATCH EXACTLY.', FDS(3))
  128.         ELSE
  129.           CALL ZCHOUT(' - VALUES WILL BE LIMITED TO BETWEEN .', FDS(3))
  130.           CALL OUTREL(T(1), FDS(3))
  131.           CALL ZCHOUT(' AND .', FDS(3))
  132.           CALL OUTREL(T(3), FDS(3))
  133.           CALL PUTCH(10, FDS(3))
  134.           CALL ZCHOUT
  135.      +         ('   AND WILL BE TESTED TO A TOLERANCE OF .', FDS(3))
  136.           CALL OUTREL(T(2), FDS(3))
  137.           CALL PUTCH(10, FDS(3))
  138.         END IF
  139.  
  140.         CALL PUTCH(10, FDS(3))
  141.         CALL ZMESS('IF MIS-ALIGNMENT  OCCURS THE PROGRAM WILL.',FDS(3))
  142.         CALL ZMESS('SEARCH FORWARD IN BOTH FILES UNTIL ONE OF.',FDS(3))
  143.         CALL ZMESS('THE FOLLOWING CONDITIONS IS MET:- .',FDS(3))
  144.  
  145.         CALL ZCHOUT('    THE 4 CHARACTER STRING ".',FDS(3))
  146.         DO 12 I = 1,4
  147.    12   CALL ZPUTCH(MARKER(I:I), FDS(3))
  148.         CALL ZMESS('" IS MET AT THE START OF A LINE.',FDS(3))
  149.         CALL ZMESS('    THE END OF INPUT IS REACHED  .',FDS(3))
  150.         CALL ZCHOUT('    .',FDS(3))
  151.         CALL ZPTINT(MAXFWD,1,FDS(3))
  152.         CALL ZMESS(' LINES HAVE BEEN EXAMINED.',FDS(3))
  153.         CALL PUTCH(10, FDS(3))
  154. C
  155.       END IF
  156. C**************************
  157. C   START OF ACTUAL PROGRAM
  158. C**************************
  159.       OK     = .TRUE.
  160.       ENDF1  = .FALSE.
  161.       ENDF2  = .FALSE.
  162.       FIRST  = .TRUE.
  163.       PRINT  = .TRUE.
  164.       MATCH  = .TRUE.
  165.       MISAL  = 0
  166.       KOUNT  = 0
  167.       LINERR = 0
  168.       LINE1  = ' '
  169.       LINE2  = ' '
  170. C  SET UP INPUT BUFFERING
  171.       NXTIN(1)  = 1
  172.       NXTLIN(1) = 1
  173.       NXTOUT(1) = 1
  174.       NXTIN(2)  = 1
  175.       NXTLIN(2) = 1
  176.       NXTOUT(2) = 1
  177. C  GIVEN RESULTS 3 (STANDARD FILE).
  178.    30 CONTINUE
  179.       LEN1 = READS(1, LINE1,I1)
  180.       IF(LEN1 .EQ. -100) GO TO 180
  181.       IF (LEN1.EQ.0 .OR. ENDF2) GO TO 30
  182. C  CALCULATED RESULTS 4 (COMPARISON FILE).
  183.    40 CONTINUE
  184.       LEN2 = READS(2, LINE2,I2)
  185.       IF(LEN2 .EQ. -100) GO TO 210
  186.       IF (LEN2.EQ.0 .OR. ENDF1) GO TO 40
  187.       IF ((I1.EQ.MIS1(1).AND.I2.EQ.MIS2(1)) .OR.
  188.      +    (I1.EQ.MIS1(2).AND.I2.EQ.MIS2(2)) .OR.
  189.      +    (I1.EQ.MIS1(3).AND.I2.EQ.MIS2(3))) THEN
  190.         KOUNT = KOUNT + 1
  191.         GO TO 40
  192.  
  193.       END IF
  194.  
  195.       NERROR = 0
  196.       A      = SPACE
  197.       B      = SPACE
  198.       POINT1 = SPACE
  199.       POINT2 = SPACE
  200.       LNFLAG = 0
  201.       K1     = 1
  202.       K2     = 1
  203.       LT1    = 0
  204.       LT2    = 0
  205.       NUMBER = .TRUE.
  206. C  IF SPACES ARE TO BE IGNORED SPNULL=.TRUE.
  207.       IF (SPNULL) THEN
  208.         CALL SHRINK
  209.  
  210.       ELSE
  211.         A      = LINE1
  212.         B      = LINE2
  213.         L1TOT  = LEN1
  214.         L2TOT  = LEN2
  215.         DO 50 I = 1,LEN1
  216.           KEYA(I)  = I
  217.           KEY1(I)  = I
  218.    50   CONTINUE
  219.         DO 60 I = 1,LEN2
  220.           KEYB(I)  = I
  221.           KEY2(I)  = I
  222.    60   CONTINUE
  223.       END IF
  224.  
  225.       IF (L1TOT.EQ.L2TOT) GO TO 70
  226.       IF (L1TOT.LT.L2TOT) LNFLAG = -1
  227.       IF (L1TOT.GT.L2TOT) LNFLAG = 1
  228. *
  229. C  IS IT AT END OF EITHER OR BOTH LINES ?
  230.    70 CONTINUE
  231.       IF(K1 .GT. L1TOT .OR. K2 .GT. L2TOT) THEN
  232.         NERROR = NERROR + L1TOT - K1 + L2TOT - K2 + 2
  233.         IF (NERROR.EQ.0) THEN
  234. C  NO MISALIGNMENT.
  235.           MISAL  = 0
  236.           KOUNT  = 0
  237.           FIRST  = .TRUE.
  238.           PRINT  = .TRUE.
  239.           IF ( .NOT. MATCH) THEN
  240. C  BACKSPACE AND LIST LINES IN F2 THAT DO NOT ALIGN.
  241.             TMP=I2
  242.             IF((MIS2(1).LT.I2) .AND. VERBOS) CALL LISTF2(MIS2(1),TMP,I2)
  243.             II1    = I1
  244.             II2    = I2
  245.             CALL ZMESS('FILES REALIGNED AT:.', FDS(3))
  246.             CALL ZCHOUT('   .', FDS(3))
  247.             CALL PUTLIN(STDPTH, FDS(3))
  248.             CALL ZCHOUT(' LINE: .', FDS(3))
  249.             CALL ZPTINT(I1, 1, FDS(3))
  250.             CALL PUTCH(10, FDS(3))
  251.             CALL ZCHOUT('   .', FDS(3))
  252.             CALL PUTLIN(CMPPTH, FDS(3))
  253.             CALL ZCHOUT(' LINE: .', FDS(3))
  254.             CALL ZPTINT(I2, 1, FDS(3))
  255.             CALL PUTCH(10, FDS(3))
  256.             MATCH  = .TRUE.
  257.           END IF
  258.  
  259.           GO TO 30
  260.  
  261.         END IF
  262.  
  263.         LTOT   = L1TOT + L2TOT
  264. C  CHECK MISALIGNMENT - IF ONE RECORD IS TWICE AS LONG AS THE OTHER OR
  265. C  FAILING THIS, IF LARGE PROPORTION OF ERRORS ON REASONABLE
  266. C  SIZED RECORD.
  267.         IF (ABS(L1TOT-L2TOT).LE.0.5*MAX(L1TOT,L2TOT)) THEN
  268.           IF ( .NOT. MATCH) THEN
  269. C  REALIGNMENT TEST STRICTER THAN MISALIGNMENT TEST.
  270. C  ARE FILES REALIGNED ?
  271.             IF (LTOT.GE.34 .AND. (LTOT-NERROR).GE.0.7059*LTOT) THEN
  272. C  FILES ALIGNED AGAIN.
  273. C  BACKSPACE AND LIST LINES IN F2 THAT DO NOT ALIGN.
  274.               TMP=I2
  275.               IF(MIS2(1).LT.I2 .AND. VERBOS) CALL LISTF2(MIS2(1),TMP,I2)
  276.               II1    = I1
  277.               II2    = I2
  278.               CALL ZMESS('FILES REALIGNED AT:.', FDS(3))
  279.               CALL ZCHOUT('   .', FDS(3))
  280.               CALL PUTLIN(STDPTH, FDS(3))
  281.               CALL ZCHOUT(' LINE: .', FDS(3))
  282.               CALL ZPTINT(I1, 1, FDS(3))
  283.               CALL PUTCH(10, FDS(3))
  284.               CALL ZCHOUT('   .', FDS(3))
  285.               CALL PUTLIN(CMPPTH, FDS(3))
  286.               CALL ZCHOUT(' LINE: .', FDS(3))
  287.               CALL ZPTINT(I2, 1, FDS(3))
  288.               CALL PUTCH(10, FDS(3))
  289.               MATCH  = .TRUE.
  290.               MISAL  = 0
  291.               KOUNT  = 0
  292.               FIRST  = .TRUE.
  293.               PRINT  = .TRUE.
  294.             END IF
  295. C  ARE FILES MISALIGNED ?
  296.           ELSE IF ((LTOT.GE.34.AND.NERROR.GT.0.88235*LTOT) .OR.
  297.      +             (LTOT.GE.8.AND.NERROR.EQ.LTOT)) THEN
  298. C  APPARENT MISALIGNMENT (LARGE NUMBER OF ERRORS).
  299.             MATCH = .FALSE.
  300.  
  301.           ELSE
  302. C  SOME ERRORS BUT INSUFFICIENT FOR MISALIGNMENT.
  303.             MISAL  = 0
  304.             KOUNT  = 0
  305.           END IF
  306.  
  307.         ELSE
  308. C  APPARENT MISALIGNMENT (ONE LINE MUCH LONGER THAN OTHER).
  309.           MATCH  = .FALSE.
  310.         END IF
  311.  
  312.         IF ( .NOT. PRINT) GO TO 100
  313. C  IF NOT AT END OF BOTH LINES SET POINTERS TO REMAINING CHARACTERS.
  314.         IF(.NOT. (K1 .GT. L1TOT .AND. K2 .GT. L2TOT)) THEN
  315.           IF (K1.GT.L1TOT) THEN
  316.             DO 80 I = K2,L2TOT
  317.               POINT2(KEY2(I) :KEY2(I))  = UPARW
  318.    80       CONTINUE
  319.  
  320.           ELSE
  321.             DO 90 I = K1,L1TOT
  322.               POINT1(KEY1(I) :KEY1(I))  = UPARW
  323.    90       CONTINUE
  324.           END IF
  325.  
  326.         END IF
  327.  
  328.           II1    = I1
  329.           II2    = I2
  330.           CALL ZMESS('-----------------.', FDS(3))
  331.           CALL ZPTINT(NERROR, 1, FDS(3))
  332.           IF(NERROR .EQ. 1) THEN
  333.             CALL ZMESS(' DIFFERENCE REPORTED AT:-.', FDS(3))
  334.           ELSE
  335.             CALL ZMESS(' DIFFERENCES REPORTED AT:-.', FDS(3))
  336.           END IF
  337.           CALL ZCHOUT('   .', FDS(3))
  338.           CALL PUTLIN(STDPTH, FDS(3))
  339.           CALL ZCHOUT(' LINE: .', FDS(3))
  340.           CALL ZPTINT(I1, 1, FDS(3))
  341.           CALL PUTCH(10, FDS(3))
  342.           CALL ZCHOUT('   .', FDS(3))
  343.           CALL PUTLIN(CMPPTH, FDS(3))
  344.           CALL ZCHOUT(' LINE: .', FDS(3))
  345.           CALL ZPTINT(I2, 1, FDS(3))
  346.           CALL PUTCH(10, FDS(3))
  347.           LINERR = LINERR + 1
  348.  
  349.         IF (LNFLAG.NE.0) THEN
  350.           IF(VERBOS) THEN
  351.             CALL ZCHOUT('LINES DO NOT CONTAIN THE SAME .', FDS(3))
  352.             CALL ZMESS ('NUMBER OF SIGNIFICANT CHARACTERS...', FDS(3))
  353.           ENDIF
  354.           N      = L2TOT - L1TOT
  355.           II1    = ABS(N)
  356.         END IF
  357.         DO 98 I = 1, LEN1
  358.    98   CALL ZPUTCH(LINE1(I:I), FDS(3))
  359.         CALL PUTCH(10, FDS(3))
  360.         IF(VERBOS) CALL ZMESS(POINT1(1:LEN1), FDS(3))
  361.         DO 99 I = 1, LEN2
  362.    99   CALL ZPUTCH(LINE2(I:I), FDS(3))
  363.         CALL PUTCH(10, FDS(3))
  364.         IF(VERBOS) CALL ZMESS(POINT2(1:LEN2), FDS(3))
  365.   100   CONTINUE
  366.         OK     = .FALSE.
  367.         IF (MATCH) THEN
  368.           GO TO 30
  369.  
  370.         ELSE
  371. C  RECORDS NOT ALIGNED.
  372.           MISAL  = MISAL + 1
  373.           KOUNT  = KOUNT + 1
  374.           IF (PRINT .AND. VERBOS) THEN
  375.             IF(MISAL .EQ. 1) THEN
  376.               CALL ZMESS(' (FIRST LINE MISALIGNMENT).', FDS(3))
  377.             ELSE IF(MISAL .EQ. 2) THEN
  378.               CALL ZMESS(' (SECOND LINE MISALIGNMENT).', FDS(3))
  379.             ELSE
  380.               CALL ZMESS(' (THIRD LINE MISALIGNMENT).', FDS(3))
  381.             ENDIF
  382.           ENDIF
  383.           IF (MISAL.LE.2) THEN
  384. C  SAVE POSITIONS OF POSSIBLE MISALIGNED RECORDS.
  385.             MATCH  = .TRUE.
  386.             MIS1(MISAL)  = I1
  387.             MIS2(MISAL)  = I2
  388.             GO TO 30
  389.  
  390.           ELSE IF (MISAL.EQ.3) THEN
  391. C  DECIDED MISALIGNMENT HAS OCCURRED,
  392. C  SWITCH OFF PRINTING,
  393. C  BACKSPACE F1 AND F2 READY TO START CROSS CHECKING.
  394.             MIS1(MISAL)  = I1
  395.             MIS2(MISAL)  = I2
  396.             PRINT  = .FALSE.
  397.             KOUNT  = 1
  398.             CALL BSPACE(1, MIS1(1))
  399.             I1     = MIS1(1) - 1
  400.             CALL BSPACE(2, MIS2(1)+1)
  401.             I2     = MIS2(1)
  402.             II1    = MIS1(1)
  403.             II2    = MIS2(1)
  404.             CALL ZMESS('-----------------.', FDS(3))
  405.             CALL ZMESS('FILES MISALIGNED AT:.', FDS(3))
  406.             CALL ZCHOUT('   .', FDS(3))
  407.             CALL PUTLIN(STDPTH, FDS(3))
  408.             CALL ZCHOUT(' LINE: .', FDS(3))
  409.             CALL ZPTINT(II1, 1, FDS(3))
  410.             CALL PUTCH(10, FDS(3))
  411.             CALL ZCHOUT('   .', FDS(3))
  412.             CALL PUTLIN(CMPPTH, FDS(3))
  413.             CALL ZCHOUT(' LINE: .', FDS(3))
  414.             CALL ZPTINT(II2, 1, FDS(3))
  415.             CALL PUTCH(10, FDS(3))
  416.  
  417.           ELSE
  418. C  ADVANCE F2 LOOKING FOR ALIGNMENT.
  419.             IF (KOUNT.LE.MAXFWD .AND. LINE2(1:4).NE.MARKER) GO TO 40
  420. C  ADVANCED F2 TO LIMIT, ADVANCE F1 AND
  421. C  BACKSPACE F2 TO START OF MISALIGNMENT.
  422.             IF (FIRST .AND. VERBOS) THEN
  423.               CALL ZCHOUT('THE FOLLOWING LINES ARE NOT .', FDS(3))
  424.               CALL ZMESS('ALIGNED (STANDARD):.', FDS(3))
  425.               FIRST  = .FALSE.
  426.             END IF
  427.             IF(VERBOS) THEN
  428.               DO 101 I = 1, LEN1
  429.   101         CALL ZPUTCH(LINE1(I:I), FDS(3))
  430.               CALL PUTCH(10, FDS(3))
  431.             ENDIF
  432.             CALL BSPACE(2, MIS2(1) + 1)
  433.             I2SV   = I2
  434.             I2     = MIS2(1) - 1
  435.             KOUNT  = 0
  436.           END IF
  437.  
  438.           GO TO 30
  439.  
  440.         END IF
  441. *
  442. C  NOT AT END OF EITHER LINE.
  443.       ELSE
  444. C  CHECK IF NEXT ITEM ON EACH LINE IS A NUMBER,
  445. C  IF IT IS, ARE THEY EQUAL TO GIVEN TOLERANCE?
  446.         KA     = K1
  447.         KB     = K2
  448.         IF (NUMBER .AND. (K1 .GT. LT1 .OR. K2 .GT. LT2)
  449.      +     .AND. .NOT. EXACT)
  450.      +     CALL CHKNUM(K1, K2, *70, NUMBER)
  451. C  NEXT ITEMS WERE NUMERIC BUT NOT EQUAL,
  452. C  OR NON NUMERIC.
  453.         IF (SAME(K1,K2)) THEN
  454.           IF(K1 .GT. LT1 .OR. K2 .GT. LT2) NUMBER = .TRUE.
  455.           GO TO 70
  456.  
  457.         END IF
  458. C  KA,KB POINT AT NON CONCURRENT CHARACTERS
  459.         KA     = K1 - 1
  460.         KB     = K2 - 1
  461. C  SEARCH FINDS NEXT PAIR OF CHARACTERS THAT AGREE(IN K1 & K2) -
  462. C   IF POSSIBLE, OR SETS K1,K2 TO LT1+1,LT2+1
  463.         CALL SEARCH(K1,K2)
  464. C  POINT AT DISAGREEING CHARACTERS.
  465.         DO 140 I = KA,K1 - 1
  466.           POINT1(KEY1(I) :KEY1(I))  = UPARW
  467.   140   CONTINUE
  468.         DO 150 I = KB,K2 - 1
  469.           POINT2(KEY2(I) :KEY2(I))  = UPARW
  470.   150   CONTINUE
  471.         NERROR = NERROR + (K1-KA) + (K2-KB)
  472. C  IF AT END OF WORD OF CHARACTERS SKIP ANY REMAINING CHARACTERS IN WORD
  473. C  AND SET THESE AS ERROR CHARACTERS.
  474.         IF(K1+1 .GT. LT1 .OR. K2+1 .GT. LT2) THEN
  475.           NUMBER = .TRUE.
  476.           DO 160 I = K1 + 1,LT1
  477.             POINT1(KEY1(I) :KEY1(I))  = UPARW
  478.   160     CONTINUE
  479.           DO 170 I = K2 + 1,LT2
  480.             POINT2(KEY2(I) :KEY2(I))  = UPARW
  481.   170     CONTINUE
  482.           IF (K1.LT.LT1) NERROR = NERROR + LT1 - K1
  483.           IF (K2.LT.LT2) NERROR = NERROR + LT2 - K2
  484.           K1     = LT1 + 1
  485.           K2     = LT2 + 1
  486.  
  487.         ELSE
  488. C  WHEN NOT AT END OF WORD INCREMENT CHARACTER COUNTERS.
  489.           K1     = K1 + 1
  490.           K2     = K2 + 1
  491.         END IF
  492.  
  493.       END IF
  494.  
  495.       GO TO 70
  496. *
  497. C  END OF FILE1 REACHED
  498.   180 CONTINUE
  499.       ENDF1  = .TRUE.
  500.       IF (ENDF2) GO TO 240
  501.       IF ( .NOT. MATCH) THEN
  502. C  END OF F1 REACHED BUT NOT F2 AND IN MISALIGNMENT
  503. C  SO LIST ALL LINES IN F2 FROM LAST ALIGNMENT
  504.         CALL LISTF2(MIS2(1),-I2SV, I2)
  505.  
  506.       ELSE
  507. C  END OF F1 REACHED BUT NOT F2 AND NOT IN MISALIGNED SITUATION
  508. C  READ TO END OF F2 PRINTING NON BLANK LINES
  509. C  NEXT LINE IN F2 SHOULD BE END OF FILE IF OK.
  510. C  NON BLANK LINES ARE COUNTED IN ERROR COUNT
  511.   190   CONTINUE
  512.         TEMP2 = READS(2, LINE2, I2)
  513.         IF(TEMP2 .EQ. -100) GO TO 210
  514.         IF (TEMP2.EQ.0) GO TO 190
  515.         LINERR = LINERR + 1
  516.         OK     = .FALSE.
  517.         CALL PUTCH(10, FDS(3))
  518.         CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
  519.         CALL ZMESS('FOLLOWING LINES LEFT IN COMPARISON FILE.', FDS(3))
  520.         DO 199 I = 1, TEMP2
  521.   199   CALL ZPUTCH(LINE2(I:I), FDS(3))
  522.         CALL PUTCH(10, FDS(3))
  523.   200   CONTINUE
  524.         TEMP2 = READS(2, LINE2, I2)
  525.         IF(TEMP2 .EQ. -100) GO TO 210
  526.         IF (TEMP2.NE.0) THEN
  527.           DO 198 I = 1, TEMP2
  528.   198     CALL ZPUTCH(LINE2(I:I), FDS(3))
  529.           CALL PUTCH(10, FDS(3))
  530.           LINERR = LINERR + 1
  531.         END IF
  532.  
  533.         GO TO 200
  534.  
  535.       END IF
  536.  
  537.       GO TO 40
  538. *
  539. C  END OF FILE2 REACHED
  540. C  IF MISALIGNED AND END OF F2 REACHED ADVANCE F1 ONE RECORD
  541. C  AND BACKSPACE F2 TO POINT WHERE MISALIGNMENT TOOK PLACE.
  542.   210 CONTINUE
  543.       IF (MISAL.GE.3 .AND. .NOT. ENDF1) THEN
  544.         IF (FIRST .AND. VERBOS) THEN
  545.           CALL ZCHOUT('THE FOLLOWING LINES ARE NOT .', FDS(3))
  546.           CALL ZMESS('ALIGNED (STANDARD):.', FDS(3))
  547.           FIRST  = .FALSE.
  548.         END IF
  549.         IF(VERBOS) THEN
  550.           DO 197 I = 1, LEN1
  551.   197     CALL ZPUTCH(LINE1(I:I), FDS(3))
  552.           CALL PUTCH(10, FDS(3))
  553.         ENDIF
  554.  
  555.         CALL BSPACE(2, MIS2(1)+1)
  556.         I2SV   = I2
  557.         I2     = MIS2(1) - 1
  558.         KOUNT  = 0
  559.         GO TO 30
  560.  
  561.       ELSE IF ( .NOT. ENDF1) THEN
  562. C  END OF F2 REACHED BUT NOT F1 AND NOT MISALIGNED
  563. C  READ TO END OF F1 PRINTING NON BLANK LINES
  564. C  FIRST LINE HAS ALREADY BEEN READ IN LINE1
  565.         ENDF2  = .TRUE.
  566.         OK     = .FALSE.
  567.         CALL PUTCH(10, FDS(3))
  568.         CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
  569.         CALL ZMESS('FOLLOWING LINES LEFT IN STANDARD FILE.', FDS(3))
  570.         DO 196 I = 1, LEN1
  571.   196   CALL ZPUTCH(LINE1(I:I), FDS(3))
  572.         CALL PUTCH(10, FDS(3))
  573.         LINERR = LINERR + 1
  574.   230   CONTINUE
  575.         TEMP1 = READS(1, LINE1,I1)
  576.         IF(TEMP1 .EQ. -100) GO TO 180
  577.         IF (TEMP1.NE.0) THEN
  578.           DO 195 I = 1, TEMP1
  579.   195     CALL ZPUTCH(LINE1(I:I), FDS(3))
  580.           CALL PUTCH(10, FDS(3))
  581.           LINERR = LINERR + 1
  582.         END IF
  583.  
  584.         GO TO 230
  585.  
  586.       END IF
  587.  
  588.       ENDF2  = .TRUE.
  589.   240 CONTINUE
  590.       IF (ENDF1) THEN
  591.         LTOT1  = I1
  592.         LTOT2  = I2
  593.         IF (I1.NE.I2) THEN
  594.           II1    = I1
  595.           II2    = I2
  596.           CALL PUTCH(10, FDS(3))
  597.           CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
  598.           CALL ZMESS('FILES ARE DIFFERENT LENGTHS.', FDS(3))
  599.  
  600.         ELSE IF (OK) THEN
  601.           CALL PUTCH(10, FDS(3))
  602.           CALL ZMESS('---- COMPARISON COMPLETE ----.', FDS(3))
  603.           CALL ZMESS('[ISTDC files are identical].', 1)
  604.           CALL ZQUIT(-2)
  605.  
  606.         END IF
  607.  
  608.       ELSE
  609.         GO TO 30
  610.  
  611.       END IF
  612.  
  613.       II1    = LINERR
  614.       CALL ZPTINT(LINERR, 1, FDS(3))
  615.       CALL ZMESS(' LINES ARE DIFFERENT.', FDS(3))
  616.       CALL ZMESS('[ISTDC files are different].', 1)
  617.       CALL ZQUIT(-2)
  618. *
  619.       END
  620. C-----------------------------------------------------------------------
  621.       BLOCK DATA BISTDC
  622. C
  623. C     .. Parameters ..
  624.       INTEGER LINLEN
  625.       PARAMETER (LINLEN=134)
  626. C     ..
  627. C     .. Scalars in Common ..
  628.       LOGICAL COM,    LBRKT,  SPNULL,  HEADER, EXACT,
  629.      +        FOLD,   VERBOS
  630.       INTEGER II1,    II2,    NERROR,  MAXFWD
  631.       CHARACTER *4        MARKER
  632. C     ..
  633. C     .. Arrays in Common ..
  634.       DOUBLE PRECISION T(3)
  635.       INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
  636. C     ..
  637. C     .. Local Scalars ..
  638.       INTEGER I
  639. C     ..
  640. C     .. Common blocks ..
  641.       COMMON /ONLNE/  II1,II2,NERROR,EXACT
  642.       COMMON /TOLS/   T
  643.       COMMON /OPTSC/  MARKER
  644.       COMMON /OPTSI/  MAXFWD, SPNULL, HEADER, FOLD, VERBOS
  645.       COMMON /ZFRDSV/ LBRKT, COM
  646. C---------------------------------------------------------
  647. C    TOOLPACK/1    Release: 3.1
  648. C---------------------------------------------------------
  649. C
  650. C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
  651. C  PROVIDE PORTABLE RECORD BACKSPACING.
  652. C
  653. C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
  654. C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
  655. C             FROM A READS CALL FOR EACH FILE
  656. C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
  657. C             EACH FILE
  658. C  SAVLIN     SAVED LINES FOR EACH FILE
  659. C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
  660. C  INFO(2..)  THE LINE NUMBER
  661. C
  662.       INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
  663.       COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
  664.       CHARACTER*134  SAVLIN(100, 2)
  665.       COMMON /STACKC/ SAVLIN
  666.       SAVE
  667. C     ..
  668.       DATA (INFO(2, I, 1),I=1, 100) /100 * 0/
  669.       DATA (INFO(2, I, 2),I=1, 100) /100 * 0/
  670.       DATA COM/.FALSE./ ,LBRKT/.FALSE./, FOLD/.FALSE./
  671.       DATA MAXFWD/20/
  672.       DATA MARKER/'.+-.'/,HEADER/.TRUE./, VERBOS/.TRUE./
  673.       DATA T/1.0D-10,1.0D-6,1.0D10/
  674.       DATA SPNULL,EXACT/.TRUE.,.FALSE./
  675.  
  676.       END
  677. C----------------------------------------------
  678.       SUBROUTINE CHKNUM(K1,K2,*,NUM)
  679. *
  680. C     .. Parameters ..
  681.       INTEGER LINLEN
  682.       PARAMETER (LINLEN=134)
  683. C     ..
  684. C     .. Scalar Arguments ..
  685.       INTEGER K1,K2
  686.       LOGICAL NUM
  687. C     ..
  688. C     .. Scalars in Common ..
  689.       DOUBLE PRECISION TOL1,TOL2,TOL3
  690.       INTEGER L1TOT,L2TOT,LEN1,LEN2,LT1,LT2
  691.       CHARACTER * (LINLEN)  A1,B2,LINE1,LINE2
  692. C     ..
  693. C     .. Arrays in Common ..
  694.       INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
  695. C     ..
  696. C     .. Local Scalars ..
  697.       DOUBLE PRECISION A,B
  698.       INTEGER KA,KB
  699.       LOGICAL EOR
  700. C     ..
  701. C     .. External Subroutines ..
  702.       EXTERNAL FREAD
  703. C     ..
  704. C     .. Intrinsic Functions ..
  705.       INTRINSIC ABS
  706. C     ..
  707. C     .. Common blocks ..
  708.       COMMON LEN1,LEN2,L1TOT,L2TOT,KEY1,KEY2,LT1,LT2
  709.       COMMON /B1/LINE1,LINE2,A1,B2
  710.       COMMON /B2/KEYA,KEYB
  711.       COMMON /TOLS/TOL1,TOL2,TOL3
  712.       SAVE
  713. C     ..
  714.       EOR    = .FALSE.
  715.       KA     = KEY1(K1)
  716.       KB     = KEY2(K2)
  717.       CALL FREAD(LINE1(1:LEN1),KA,A,*30,*50)
  718.    10 CONTINUE
  719.       CALL FREAD(LINE2(1:LEN2),KB,B,*40,*50)
  720.    20 CONTINUE
  721.       NUM    = .TRUE.
  722.       LT1    = KEYA(KA-1)
  723.       LT2    = KEYB(KB-1)
  724.       IF (LT1*LT2.EQ.0)  GO TO 50
  725.  
  726.       IF ((ABS(A-B).LE.TOL2.AND..NOT.EOR) .OR.
  727.      +    (ABS(A).LE.TOL1.AND.ABS(B).LE.TOL1.AND..NOT.EOR) .OR.
  728.      +    (ABS(A).GE.TOL3.AND.ABS(B).GE.TOL3.AND..NOT.EOR)) THEN
  729. C  NUMERIC VALUES ARE NEARLY EQUAL OR
  730. C  INDIVIDUAL NUMBERS ARE VERY SMALL OR VERY LARGE.
  731.         K1 = LT1 + 1
  732.         K2     = LT2 + 1
  733.         RETURN1
  734.  
  735.       END IF
  736. C  NUMERIC BUT SIGNIFICANT DIFFERENCE BETWEEN TWO NUMBERS.
  737.       RETURN
  738. *
  739. C  NO MORE NUMBERS LEFT IN EITHER OR BOTH LINES.
  740. C  NONE IN LINE1.
  741.    30 CONTINUE
  742.       EOR    = .TRUE.
  743.       GO TO 10
  744. C  NONE IN LINE2.
  745.    40 CONTINUE
  746.       EOR    = .TRUE.
  747.       GO TO 20
  748. *
  749. C  NON NUMERIC STRING IN ONE OR OTHER LINE.
  750.    50 CONTINUE
  751.       NUM    = .FALSE.
  752.  
  753.       RETURN
  754.       END
  755. C----------------------------------------------
  756. *
  757.       SUBROUTINE LISTF2(M, N1, I2)
  758. *
  759. C     .. Parameters ..
  760.       INTEGER LINLEN
  761.       PARAMETER (LINLEN=134)
  762. C     ..
  763. C     .. Scalar Arguments ..
  764.       INTEGER M,N1
  765. C     ..
  766. C     .. Scalars in Common ..
  767.       CHARACTER*(LINLEN) A,B,LINE1,LINE2
  768. C     ..
  769. C     .. Local Scalars ..
  770.       INTEGER I,N, TEMP2, J , I2
  771. C     ..
  772. C     .. External Functions ..
  773.       INTEGER READS
  774.       EXTERNAL READS
  775. C     ..
  776. C     .. External Subroutines ..
  777.       EXTERNAL PUTCH,ZMESS,ZPUTCH
  778. C     ..
  779. C     .. Intrinsic Functions ..
  780.       INTRINSIC ABS
  781. C     ..
  782. C     .. Common blocks ..
  783.       COMMON /B1/LINE1,LINE2,A,B
  784. C---------------------------------------------------------
  785. C    TOOLPACK/1    Release: 3.1
  786. C---------------------------------------------------------
  787. C
  788. C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
  789. C  PROVIDE PORTABLE RECORD BACKSPACING.
  790. C
  791. C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
  792. C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
  793. C             FROM A READS CALL FOR EACH FILE
  794. C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
  795. C             EACH FILE
  796. C  SAVLIN     SAVED LINES FOR EACH FILE
  797. C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
  798. C  INFO(2..)  THE LINE NUMBER
  799. C
  800.       INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
  801.       COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
  802.       CHARACTER*134  SAVLIN(100, 2)
  803.       COMMON /STACKC/ SAVLIN
  804.       SAVE
  805. C     ..
  806.       N      = ABS(N1)
  807.       IF (N1 .GT. 0) THEN
  808.         CALL BSPACE(2,M)
  809.       END IF
  810.  
  811.       CALL ZMESS
  812.      +('THE FOLLOWING LINES ARE NOT ALIGNED (COMPARISON):.', FDS(3))
  813.       DO 20 I = M,N - 1
  814.         TEMP2 = READS(2,LINE2,I2)
  815.         IF (TEMP2.NE.0) THEN
  816.           DO 21 J = 1,TEMP2
  817.    21     CALL ZPUTCH(LINE2(J:J), FDS(3))
  818.           CALL PUTCH(10, FDS(3))
  819.         ENDIF
  820.    20 CONTINUE
  821.  
  822.       TEMP2 = READS(2,LINE2,I2)
  823.       IF (N1.LT.0) THEN
  824.         DO 22 J = 1,TEMP2
  825.    22   CALL ZPUTCH(LINE2(J:J), FDS(3))
  826.         CALL PUTCH(10, FDS(3))
  827.         CALL ZMESS('END OF STANDARD FILE.', FDS(3))
  828.       END IF
  829.  
  830.       RETURN
  831.       END
  832. C----------------------------------------------
  833. *
  834.       SUBROUTINE SHRINK
  835. *
  836. C     .. Parameters ..
  837.       INTEGER LINLEN
  838.       PARAMETER (LINLEN=134)
  839. C     ..
  840. C     .. Scalars in Common ..
  841.       INTEGER L1,L1TOT,L2,L2TOT
  842.       CHARACTER * (LINLEN)  A,B,LN1,LN2
  843. C     ..
  844. C     .. Arrays in Common ..
  845.       INTEGER KEY1(LINLEN),KEY2(LINLEN),KEYA(LINLEN),KEYB(LINLEN)
  846. C     ..
  847. C     .. Local Scalars ..
  848.       INTEGER I
  849. C     ..
  850. C     .. Common blocks ..
  851.       COMMON L1,L2,L1TOT,L2TOT,KEY1,KEY2
  852.       COMMON /B1/LN1,LN2,A,B
  853.       COMMON /B2/KEYA,KEYB
  854.       SAVE
  855. C     ..
  856.       L1TOT  = 0
  857.       L2TOT  = 0
  858.       DO 10 I = 1,L1
  859.         IF (LN1(I:I).NE.' ') THEN
  860.           L1TOT  = L1TOT + 1
  861.           A(L1TOT:L1TOT)  = LN1(I:I)
  862.           KEY1(L1TOT)  = I
  863.           KEYA(I)  = L1TOT
  864.  
  865.         ELSE
  866.           KEYA(I)  = 0
  867.         END IF
  868.  
  869.    10 CONTINUE
  870.       DO 20 I = 1,L2
  871.         IF (LN2(I:I).NE.' ') THEN
  872.           L2TOT  = L2TOT + 1
  873.           B(L2TOT:L2TOT)  = LN2(I:I)
  874.           KEY2(L2TOT)  = I
  875.           KEYB(I)  = L2TOT
  876.  
  877.         ELSE
  878.           KEYB(I)  = 0
  879.         END IF
  880.  
  881.    20 CONTINUE
  882.  
  883.       RETURN
  884.       END
  885. C----------------------------------------------
  886. *
  887.       SUBROUTINE SEARCH(K1,K2)
  888. C     .. Parameters ..
  889.       INTEGER LINLEN
  890.       PARAMETER (LINLEN=134)
  891. C     ..
  892. C     .. Scalar Arguments ..
  893.       INTEGER K1,K2
  894. C     ..
  895. C     .. Scalars in Common ..
  896.       INTEGER L1,L2,LA,LA1,LB,LB2
  897.       CHARACTER * (LINLEN)  A,A1,B,B2
  898. C     ..
  899. C     .. Arrays in Common ..
  900.       INTEGER KY1(LINLEN),KY2(LINLEN)
  901. C     ..
  902. C     .. Local Scalars ..
  903.       INTEGER K,KA,KB,L,M,N
  904.       LOGICAL INAREA,OUTBOX
  905. C     ..
  906. C     .. Intrinsic Functions ..
  907.       INTRINSIC INDEX
  908. C     ..
  909. C     .. Common blocks ..
  910.       COMMON L1,L2,LA1,LB2,KY1,KY2,LA,LB
  911.       COMMON /B1/A1,B2,A,B
  912.       SAVE
  913. C     ..
  914.       OUTBOX = .FALSE.
  915.       L      = 0
  916. C   SPACES BETWEEN CHARACTER STRINGS ACT AS DELIMITERS.
  917.       KA     = K1 - 1
  918.       IF (K2 .GT.LB) THEN
  919.         KB     = K2 - 1
  920.  
  921.       ELSE
  922.         KB     = K2
  923.       END IF
  924. C  IS KA'TH CHARACTER IN A = KB'TH CHARACTER IN B ?
  925. C  IF SO ARE NEXT PAIR OF CHARACTERS SAME ?
  926.    10 CONTINUE
  927.       IF (A(KA:KA) .EQ. B(KB:KB)) THEN
  928.         IF (KA+1 .LE. LA .AND. KB+1 .LE. LB) THEN
  929.           IF(A(KA+1:KA+1) .NE. B(KB+1:KB+1)) GO TO 20
  930.         END IF
  931.  
  932.         K1     = KA
  933.         K2     = KB
  934.         GO TO 30
  935.  
  936.       END IF
  937. *
  938. C  CHARACTERS DON'T AGREE OR ONE OR OTHER LINES AT END
  939. C  OR SECOND CHARACTER DOESN'T AGREE
  940. *
  941. C  ARE WE WITHIN 3 CHARACTERS OF EITHER END
  942. C  OR WITHIN THE 3 CHARACTER SEARCH AREA OF THE ENTRY POINT ?
  943. C  CHECK UPTO 8 POSSIBLE COMBINATIONS TO FIND COMPARISON.
  944.    20 CONTINUE
  945.       INAREA = (KA.LE.K1+1) .AND. (KB.LE.K2+1)
  946.       IF (KA+2 .GT. LA .OR. KB+2 .GT. LB .OR. INAREA) THEN
  947.         KB     = KB + 1
  948.         IF((KB.LE.LB.AND.(KB.LE.K2+1)).OR.(KB.LE.LB.AND.OUTBOX)) GOTO 10
  949.         KA = KA + 1
  950.         IF((KA.LE.LA.AND.(KA.LE.K1+1)) .OR. (KA.LE.LA.AND.OUTBOX)) THEN
  951. C  L RESET TO 0 WHEN KA LEAVES BOX FOR SECOND TIME
  952.           IF (L.EQ.3 .AND. .NOT. (KA.LE.K1+1)) L      = 0
  953.           KB     = K2 - 1 + L
  954.           GO TO 10
  955. *
  956. C  OUT OF THE BOX SEARCH AREA
  957. C  NOW CHECK END OF BOTH OR EITHER LINE.
  958.         ELSE IF (KA.GT.LA .AND. KB.GT.LB) THEN
  959.           K1     = LA + 1
  960.           K2     = LB + 1
  961.           GO TO 30
  962. C  ARE WE AT THE END OF LINE A ONLY OR AT NEITHER END ?
  963.         ELSE IF (KA.GT.LA .OR. KB.LE.LB) THEN
  964. C  RESET POINTER FOR LINE A BUT LEAVE POINTER FOR LINE B.
  965. C  L SET TO 3 TO PREVENT REPEATING CHECKS IN BOX.
  966.           OUTBOX = .TRUE.
  967.           L      = 3
  968.           KA     = K1 - 1
  969. C  ARE WE AT THE END OF LINE B ONLY ? - YES !
  970.         ELSE
  971. C  RESET POINTER FOR LINE B BUT LEAVE POINTER FOR LINE A.
  972.           OUTBOX = .TRUE.
  973.           KB     = K2 - 1
  974.         END IF
  975.  
  976.         GO TO 10
  977. *
  978. C  CAN'T FIND SINGLE CHARACTER COMPARISON
  979. C  CHECK SUCCESSIVE GROUPS OF 3 CHARACTERS IN REST OF LINE.
  980.       ELSE
  981.         N      = INDEX(B(KB:LB),A(KA:KA+2))
  982.         IF (N.EQ.0) THEN
  983.           KA     = KA + 1
  984.           KB     = K2 - 1
  985.           GO TO 10
  986.  
  987.         END IF
  988.  
  989.         K1     = KA
  990.         K2     = N + KB - 1
  991.       END IF
  992.    30 CONTINUE
  993.  
  994.       RETURN
  995.       END
  996. C----------------------------------------------
  997.       LOGICAL FUNCTION SAME(K1,K2)
  998. C   SETS LT1,LT2 TO POSITION OF CHARACTER BEFORE NEXT SPACE OR
  999. C   END OF LINE IN ORIGINAL LINES.
  1000. C   THUS SPACES BETWEEN CHARACTER STRINGS WILL ACT AS DELIMITERS.
  1001. C     .. Parameters ..
  1002.       INTEGER LINLEN
  1003.       PARAMETER (LINLEN=134)
  1004. C     ..
  1005. C     .. Scalar Arguments ..
  1006.       INTEGER K1,K2
  1007. C     ..
  1008. C     .. Scalars in Common ..
  1009.       INTEGER L1TOT,L2TOT,LEN1,LEN2,LT1,LT2
  1010.       CHARACTER * (LINLEN)  A,A1,B,B2
  1011. C     ..
  1012. C     .. Arrays in Common ..
  1013.       INTEGER KEY1(LINLEN),KEY2(LINLEN)
  1014. C     ..
  1015. C     .. Local Scalars ..
  1016.       INTEGER KA,KB,N
  1017. C     ..
  1018. C     .. Intrinsic Functions ..
  1019.       INTRINSIC INDEX
  1020. C     ..
  1021. C     .. Common blocks ..
  1022.       COMMON LEN1,LEN2,L1TOT,L2TOT,KEY1,KEY2,LT1,LT2
  1023.       COMMON /B1/A1,B2,A,B
  1024.       SAVE
  1025. C     ..
  1026.       IF (K1.GT.LT1) THEN
  1027.         KA     = KEY1(K1)
  1028.         N      = INDEX(A1(KA:LEN1),' ')
  1029.         IF (N.EQ.0) THEN
  1030.           LT1    = L1TOT
  1031.  
  1032.         ELSE
  1033.           LT1    = K1 + N - 2
  1034.         END IF
  1035.  
  1036.       END IF
  1037.  
  1038.       IF (K2.GT.LT2) THEN
  1039.         KB     = KEY2(K2)
  1040.         N      = INDEX(B2(KB:LEN2),' ')
  1041.         IF (N.EQ.0) THEN
  1042.           LT2    = L2TOT
  1043.  
  1044.         ELSE
  1045.           LT2    = K2 + N - 2
  1046.         END IF
  1047.  
  1048.       END IF
  1049.  
  1050.       SAME   = A(K1:K1) .EQ. B(K2:K2)
  1051.       K1     = K1 + 1
  1052.       K2     = K2 + 1
  1053.  
  1054.       RETURN
  1055.       END
  1056. C----------------------------------------------
  1057. C
  1058. C    READS A SINGLE NUMBER IN FREE FORMAT FROM INTERNAL BUFFER RECORD
  1059. C
  1060.       SUBROUTINE FREAD(RECORD,I,A,*,*)
  1061. C     .. Scalar Arguments ..
  1062.       DOUBLE PRECISION A
  1063.       INTEGER I
  1064.       CHARACTER * (*)  RECORD
  1065. C     ..
  1066. C     .. Scalars in Common ..
  1067.       LOGICAL COM,LBRKT
  1068. C     ..
  1069. C     .. Local Scalars ..
  1070.       DOUBLE PRECISION B,C,CC
  1071.       INTEGER EPOS,J,L,MAXREC,NEXP,P10,PPOS,SIGN
  1072.       LOGICAL EXNUM,EXPO,LB,NUMB,PMSIGN,POINT
  1073.       CHARACTER *18 CH
  1074. C     ..
  1075. C     .. Local Arrays ..
  1076.       CHARACTER D(0:17)
  1077. C     ..
  1078. C     .. External Functions ..
  1079.       LOGICAL SPSKIP
  1080.       EXTERNAL SPSKIP
  1081. C     ..
  1082. C     .. Intrinsic Functions ..
  1083.       INTRINSIC ABS,LEN,NINT
  1084. C     ..
  1085. C     .. Common blocks ..
  1086.       COMMON /ZFRDSV/ LBRKT, COM
  1087.       SAVE
  1088. C     ..
  1089. C     .. Equivalences ..
  1090.       EQUIVALENCE (CH,D)
  1091. C     ..
  1092.       DATA CH/'0123456789+-.EDed '/
  1093. *
  1094.       LB     = .FALSE.
  1095.       MAXREC = LEN(RECORD)
  1096. C  SKIP SPACES.
  1097.    10 CONTINUE
  1098.       IF (SPSKIP(RECORD,I)) THEN
  1099.         LBRKT  = .FALSE.
  1100.         I      = MAXREC + 1
  1101.  
  1102.       ELSE
  1103.         GO TO 20
  1104.  
  1105.       END IF
  1106.  
  1107.       RETURN1
  1108.  
  1109.    20 CONTINUE
  1110. C  CHECK TO SEE IF EITHER ( OR , ARE BEING USED AS DELIMITERS.
  1111.       IF (RECORD(I:I).EQ.',') THEN
  1112. C  ,, OR (, CONSIDERED AN ERROR.
  1113.         IF (COM .OR. (LBRKT.AND.LB)) GO TO 120
  1114.         COM    = .TRUE.
  1115.         I      = I + 1
  1116.         GO TO 10
  1117.  
  1118.       ELSE IF (RECORD(I:I).EQ.'(') THEN
  1119. C  ,( OR (( CONSIDERED AN ERROR.
  1120.         IF (COM .OR. LBRKT) GO TO 120
  1121.         I      = I + 1
  1122.         LBRKT  = .TRUE.
  1123.         LB     = .TRUE.
  1124.         GO TO 10
  1125.  
  1126.       ELSE IF (RECORD(I:I).EQ.')') THEN
  1127. C  (...) CONSIDERED OK, BUT () OR ) ON ITS OWN IS AN ERROR.
  1128.         IF (LBRKT .AND. .NOT. LB) THEN
  1129.           I      = I + 1
  1130.           LBRKT  = .FALSE.
  1131.  
  1132.         ELSE
  1133.           GO TO 120
  1134.  
  1135.         END IF
  1136.  
  1137.         GO TO 10
  1138.  
  1139.       END IF
  1140. C
  1141. C  FOUND NON SPACE CHARACTER WHICH IS NOT , ( OR )
  1142. C  TRY AND INTERPRET AS NUMBER.
  1143. C
  1144.       COM    = .FALSE.
  1145.       PMSIGN = .FALSE.
  1146.       POINT  = .FALSE.
  1147.       NUMB   = .FALSE.
  1148.       EXPO   = .FALSE.
  1149.       EXNUM  = .FALSE.
  1150.       SIGN   = 1
  1151.       B      = 0.0D0
  1152.       C      = 0.0D0
  1153.       P10    = 0
  1154.       L      = I
  1155.    30 CONTINUE
  1156.       I      = L
  1157.       IF (I.GT.MAXREC) THEN
  1158.         LBRKT  = .FALSE.
  1159.         GO TO 100
  1160.       END IF
  1161.  
  1162.       DO 90 J = 0,17
  1163.         IF (RECORD(I:I) .EQ. D(J)) THEN
  1164.           L      = L + 1
  1165.           IF (J.LE.9) THEN
  1166.             IF (POINT .AND. .NOT. EXPO) P10    = PPOS - I
  1167.             B      = B * 1.0D1 + DBLE(J)
  1168.             IF (EXPO) THEN
  1169.               EXNUM  = .TRUE.
  1170.  
  1171.             ELSE
  1172.               NUMB   = .TRUE.
  1173.               C      = DBLE(SIGN) * B
  1174.             END IF
  1175.  
  1176.           ELSE
  1177.             GO TO (40,50,60,70,70,70,70,80),J - 9
  1178. C  + SIGN OR SPACE AFTER E OR D.
  1179.    40       CONTINUE
  1180.             IF (PMSIGN) GO TO 120
  1181.             SIGN   = 1
  1182.             PMSIGN = .TRUE.
  1183.             GO TO 30
  1184. C  - SIGN.
  1185.    50       CONTINUE
  1186.             IF (PMSIGN) GO TO 120
  1187.             SIGN   = -1
  1188.             PMSIGN = .TRUE.
  1189.             GO TO 30
  1190. C  . IN MANTISSA.
  1191.    60       CONTINUE
  1192.             IF (POINT) GO TO 120
  1193.             PPOS   = I
  1194.             POINT  = .TRUE.
  1195.             PMSIGN = .TRUE.
  1196.             GO TO 30
  1197. C  E OR D INITIATING EXPONENT (UPPER OR LOWER CASE)
  1198.    70       CONTINUE
  1199.             IF (EXPO .OR. .NOT. NUMB) GO TO 120
  1200.             C      = DBLE(SIGN) * B
  1201.             B      = 0.0D0
  1202.             EXPO   = .TRUE.
  1203.             EPOS   = I
  1204.             SIGN   = 1
  1205.             PMSIGN = .FALSE.
  1206.             GO TO 30
  1207. C  SPACE SIGNIFYING EITHER END OF NUMBER OR POSITIVE EXPONENT.
  1208.    80       CONTINUE
  1209.             IF (EXPO) THEN
  1210. C  POSSIBLE EXPONENT CONFIGURATIONS...
  1211. C        E SPACE       (GET NEXT CHARACTER) OR...
  1212.               IF (I-1.EQ.EPOS) GO TO 30
  1213. C        E +/-   SPACE (ERROR) OR...
  1214. C        E NUM   SPACE (END OF NUMBER) OR...
  1215. C        E SPACE SPACE (GET NEXT CHARACTER) OR...
  1216.               IF (I-2.EQ.EPOS) THEN
  1217.                 IF (PMSIGN) GO TO 120
  1218.                 IF (EXNUM) GO TO 100
  1219.                 GO TO 30
  1220.  
  1221.               END IF
  1222. C        E SPACE SPACE SPACE (ERROR) OR...
  1223. C        E SPACE =/-   SPACE (ERROR)
  1224. C  THREE SPACES AFTER E OR D IS ILLEGAL NUMBER,
  1225. C  SPACE AFTER SIGN IS ERROR.
  1226.               IF (I-3.EQ.EPOS .AND. .NOT. EXNUM) THEN
  1227.                 IF ( .NOT. PMSIGN) I = EPOS + 1
  1228.                 GO TO 120
  1229.               END IF
  1230.  
  1231.             ELSE
  1232. C  SIGN FOLLOWED BY SPACE IS ERROR
  1233.               IF (PMSIGN .AND. .NOT. NUMB) GO TO 120
  1234.             END IF
  1235.             GO TO 100
  1236.  
  1237.           END IF
  1238.           GO TO 30
  1239.  
  1240.         END IF
  1241.    90 CONTINUE
  1242. C
  1243. C  NUMBER MUST HAVE BEEN READ AT THIS POINT.
  1244. C  IF NEXT CHARACTER IS , OK.
  1245. C  IF NEXT CHARACTER IS ) AND NO OUTSTANDING ( THEN ERROR.
  1246. C  IF NEXT CHARACTER ( AND NO OUTSTANDING ( THEN OK.
  1247. C
  1248.       IF (RECORD(I:I).EQ.',') THEN
  1249.         I      = I + 1
  1250.         COM    = .TRUE.
  1251.         GO TO 100
  1252.       ELSE IF (RECORD(I:I).EQ.')') THEN
  1253.         IF (LBRKT) THEN
  1254.           LBRKT  = .FALSE.
  1255.           I      = I + 1
  1256.           GO TO 100
  1257.         END IF
  1258.       ELSE IF (RECORD(I:I).EQ.'(') THEN
  1259.         IF ( .NOT. LBRKT) THEN
  1260.           LBRKT  = .TRUE.
  1261.           I      = I + 1
  1262.           GO TO 100
  1263.         END IF
  1264.       END IF
  1265.  
  1266.       GO TO 120
  1267. C
  1268. C  ASSEMBLE NUMBER.
  1269. C
  1270.   100 CONTINUE
  1271.       IF ( .NOT. NUMB) THEN
  1272.         IF (EXPO) I = EPOS
  1273.         GO TO 120
  1274.       END IF
  1275.  
  1276.       IF (EXPO) THEN
  1277.         IF (.NOT. EXNUM) GO TO 120
  1278.         P10 = P10 + NINT(SIGN*B)
  1279.       END IF
  1280. C
  1281. C  NORMALIZE NUMBER
  1282. C
  1283.       CC     = C
  1284.       NEXP   = P10
  1285.   110 CONTINUE
  1286.       IF (ABS(CC).GE.10.0D0) THEN
  1287.         CC     = CC/10.0D0
  1288.         NEXP   = NEXP + 1
  1289.         GO TO 110
  1290.  
  1291.       ELSE IF (ABS(CC).LT.0.1D0 .AND. ABS(CC).GT.1.0D- 300) THEN
  1292.         CC     = CC*10.0D0
  1293.         NEXP   = NEXP - 1
  1294.         GO TO 110
  1295.  
  1296.       END IF
  1297. C
  1298. C  CHECK FOR OVERFLOW OR UNDERFLOW
  1299. C
  1300.       IF (NEXP.GT.300 .OR. NEXP.EQ.300 .AND. ABS(CC).GT.1.0D0) THEN
  1301.         P10    = 300
  1302.         C      = 0.99999999999999D0
  1303.  
  1304.       ELSE IF(NEXP.LT. - 300 .OR.
  1305.      +        NEXP.EQ. - 300 .AND. ABS(CC).LT.1.0D0)THEN
  1306.         A      = 0.0D0
  1307.         RETURN
  1308.  
  1309.       ELSE
  1310.         C      = CC
  1311.         P10    = NEXP
  1312.       END IF
  1313.  
  1314.       A      = C * 10.0D0**P10
  1315.       RETURN
  1316. C
  1317. C  NON NUMERIC VALUE.
  1318. C
  1319.   120 CONTINUE
  1320.       RETURN2
  1321.  
  1322.       END
  1323. C----------------------------------------------
  1324. C
  1325. C   GIVES LENGTH OF CHARACTER VARIABLE LESS END SPACES
  1326. C
  1327.       INTEGER FUNCTION LENG(A)
  1328. C     .. Scalar Arguments ..
  1329.       CHARACTER*(*) A
  1330. C     ..
  1331. C     .. Intrinsic Functions ..
  1332.       INTRINSIC LEN
  1333. C     ..
  1334.       LENG=LEN(A)
  1335.    10 IF (A(LENG:LENG).EQ.' ' .AND. LENG.GT.1) THEN
  1336.           LENG=LENG-1
  1337.           GOTO 10
  1338.       END IF
  1339.  
  1340.       END
  1341. C----------------------------------------------
  1342. C
  1343. C   SKIPS TO NEXT NON-SPACE CHARACTER IN INTERNAL FILE
  1344. C
  1345.       LOGICAL FUNCTION SPSKIP(RECORD,K)
  1346. *
  1347. C     .. Scalar Arguments ..
  1348.       INTEGER K
  1349.       CHARACTER * (*)  RECORD
  1350. C     ..
  1351. C     .. Local Scalars ..
  1352.       INTEGER L
  1353. C     ..
  1354. C     .. Intrinsic Functions ..
  1355.       INTRINSIC LEN
  1356. C     ..
  1357.       L      = LEN(RECORD)
  1358.       IF (K.GT.L) THEN
  1359.         K      = 1
  1360.         SPSKIP = .TRUE.
  1361.         RETURN
  1362.  
  1363.       END IF
  1364.  
  1365.    10 CONTINUE
  1366.       IF (RECORD(K:K).EQ.' ') THEN
  1367.         K      = K + 1
  1368.         IF (K.LE.L) GO TO 10
  1369.         K      = 1
  1370.         SPSKIP = .TRUE.
  1371.  
  1372.       ELSE
  1373.         SPSKIP = .FALSE.
  1374.       END IF
  1375.       END
  1376. C---------------------------------------------------------------------
  1377. C
  1378.       SUBROUTINE NAMES(OPT, PATH)
  1379.  
  1380.       INTEGER PATH(*), MSG1(16), MSG2(18), MSG3(14)
  1381.       INTEGER STAT, OPT, I
  1382.  
  1383.       INTEGER ZGTCMD
  1384.       EXTERNAL ZGTCMD,ZPRMPT
  1385.  
  1386.       DATA (MSG1(I),I=1,16)/83,116,97,110,100,97,114,100,
  1387.      +                      32,102,105,108,101,58,32,129/
  1388.       DATA (MSG2(I),I=1,18)/67,111,109,112,97,114,105,115,
  1389.      +             111,110,32,102,105,108,101,58,32,129/
  1390.       DATA (MSG3(I),I=1,14)/79,117,116,112,117,116,32,
  1391.      +                      102,105,108,101,58,32,129/
  1392.  
  1393.       IF(OPT .EQ. 1) CALL ZPRMPT(MSG1)
  1394.       IF(OPT .EQ. 2) CALL ZPRMPT(MSG2)
  1395.       IF(OPT .EQ. 3) CALL ZPRMPT(MSG3)
  1396.       STAT = ZGTCMD(PATH, 0)
  1397.  
  1398.       RETURN
  1399.       END
  1400. C---------------------------------------------------------------------
  1401. C
  1402. C  IDENTIFY OPTIONS
  1403. C
  1404. C     M     MAX LINES FORWARD TO RESYNC
  1405. C     S     SPACE SIGNIFICANCE
  1406. C     E     EXACT
  1407. C     H     HEADERS
  1408. C     T     TOLERANCES
  1409. C     R     RESYNC MARKER
  1410. C     F     FOLDING
  1411. C
  1412.       SUBROUTINE IDOPS(BUFFER)
  1413.  
  1414.       INTEGER C, I, LIMIT, POINT
  1415.       INTEGER BUFFER(*), LHS(134), RHS(134)
  1416.       CHARACTER CC
  1417.       CHARACTER*134 TEMPL
  1418.       CHARACTER*4 MARKER
  1419.       INTEGER II1, II2, NERROR, MAXFWD
  1420.       LOGICAL SPNULL, EXACT, HEADER, FOLD, VERBOS
  1421.       DOUBLE PRECISION T(3), VAL
  1422.       COMMON /TOLS/  T
  1423.       COMMON /ONLNE/ II1, II2, NERROR, EXACT
  1424.       COMMON /OPTSC/ MARKER
  1425.       COMMON /OPTSI/ MAXFWD, SPNULL, HEADER, FOLD, VERBOS
  1426.       SAVE
  1427.  
  1428.       INTEGER ZLOWER, LENGTH, CTOI, INDEXX
  1429.       CHARACTER ZCITOC
  1430.       EXTERNAL CTOI,INDEXX,LENGTH,ZCITOC,ZLOWER,ZSPLIT
  1431.  
  1432.       I = 1
  1433.       C = ZLOWER(BUFFER(1))
  1434.       CALL ZSPLIT(BUFFER, LHS, RHS)
  1435.       LIMIT = LENGTH(RHS)
  1436.  
  1437.       IF(C .EQ. 109) THEN
  1438.         MAXFWD = CTOI(RHS, I)
  1439.         IF(MAXFWD .LT. 2)  MAXFWD = 2
  1440.         IF(MAXFWD .GT. 99) MAXFWD = 99
  1441.  
  1442.       ELSE IF(C .EQ. 115) THEN
  1443.         SPNULL = .NOT. SPNULL
  1444.  
  1445.       ELSE IF(C .EQ. 101) THEN
  1446.         EXACT = .NOT. EXACT
  1447.  
  1448.       ELSE IF(C .EQ. 104) THEN
  1449.         HEADER = .NOT. HEADER
  1450.  
  1451.       ELSE IF(C .EQ. 116) THEN
  1452.         C = BUFFER(2)
  1453.         DO 5 I = 1, LIMIT
  1454.     5   TEMPL(I:I) = ZCITOC(RHS(I), CC)
  1455.         I = 1
  1456.         CALL FREAD(TEMPL(1:LIMIT), I, VAL, *10, *10)
  1457.         IF(C .EQ. 49) THEN
  1458.           T(1) = VAL
  1459.         ELSE IF(C .EQ. 51) THEN
  1460.           T(3) = VAL
  1461.         ELSE
  1462.           T(2) = VAL
  1463.         ENDIF
  1464.  
  1465.       ELSE IF(C .EQ. 114) THEN
  1466.         MARKER(1:4) = '    '
  1467.         POINT = INDEXX(BUFFER, 61)
  1468.         DO 20 I = 1, 4
  1469.           IF(BUFFER(I+POINT) .EQ. 129) GO TO 21
  1470.           MARKER(I:I) = ZCITOC(BUFFER(I+POINT), CC)
  1471.    20   CONTINUE
  1472.    21   CONTINUE
  1473.  
  1474.       ELSE IF(C .EQ. 102) THEN
  1475.         FOLD = .NOT. FOLD
  1476.  
  1477.       ELSE IF(C .EQ. 118) THEN
  1478.         VERBOS = .NOT. VERBOS
  1479.  
  1480.       ENDIF
  1481.  
  1482.    10 CONTINUE
  1483.  
  1484.       RETURN
  1485.       END
  1486. C-------------------------------------------------------
  1487. C
  1488. C  A RATHER SIMPLISTIC REAL NUMBER OUTPUT ROUTINE, THE NUMBER
  1489. C  ACTUALLY PRINTED MAY NOT BE QUITE CORRECT DUE TO ERRORS
  1490. C  INTRODUCED WHILST SCALING.
  1491. C
  1492.       SUBROUTINE OUTREL(VAL, FD)
  1493.  
  1494.       INTEGER FD, EXP
  1495.       DOUBLE PRECISION   VAL, TEMP
  1496.  
  1497.       EXTERNAL PUTCH,ZCHOUT,ZPTINT
  1498.  
  1499.       TEMP = ABS(VAL)
  1500.       IF(VAL .LT. 0) THEN
  1501.         CALL PUTCH(45, FD)
  1502.       ELSE IF(VAL .EQ. 0) THEN
  1503.         CALL ZCHOUT('0..0.', FD)
  1504.         RETURN
  1505.       ENDIF
  1506.  
  1507.       EXP = 0
  1508.    10 CONTINUE
  1509.         IF(TEMP .GT. 10.0D0) THEN
  1510.           TEMP = TEMP / 10.0D0
  1511.           EXP = EXP + 1
  1512.         ELSE IF(TEMP .LT. 1.0D0) THEN
  1513.           TEMP = TEMP * 10.0D0
  1514.           EXP = EXP - 1
  1515.         ELSE
  1516.           GO TO 20
  1517.         ENDIF
  1518.       GO TO 10
  1519.  
  1520.    20 CONTINUE
  1521.       CALL ZPTINT(INT(TEMP), 1, FD)
  1522.       TEMP = (TEMP - INT(TEMP)) * 1000.0D0
  1523.       CALL PUTCH(46, FD)
  1524.       CALL ZPTINT(INT(TEMP), 1, FD)
  1525.       CALL PUTCH(69, FD)
  1526.       CALL ZPTINT(EXP, 1, FD)
  1527.  
  1528.       RETURN
  1529.       END
  1530. C---------------------------------------------------
  1531. C
  1532. C  REPLACE THE READ STATEMENT.....THIS IS NECESSARY
  1533. C  BOTH FOR THE PORTABILITY ISSUE AND TO ALLOW FOR
  1534. C  BACKSPACING (REALLY MEANS GOING BACK MULTIPLE LINES
  1535. C  IN THIS CONTEXT).
  1536. C
  1537. C  FILE    THE FILE TO BE READ
  1538. C  LINE    THE RETURNED LINE
  1539. C  READS   EOF TO INDICATE AN ERROR OR END-OF-FILE CONDITION,
  1540. C          OTHERWISE LENGTH OF LINE READ
  1541. C
  1542. C  A BUFFER OF UP TO 100 LINES IS MAINTAINED FOR EACH INPUT FILE.
  1543. C  THESE ARE USED AS RING BUFFERS SO THAT BACKSPACE CAN BE IMPLEMENTED.
  1544. C
  1545.       INTEGER FUNCTION READS(FILE, LINE, NUMB)
  1546.  
  1547.       INTEGER       FILE, STATUS, I, POINT, C, MAXFWD, NUMB, J
  1548.       LOGICAL       SPNULL, HEADER, FOLD, VERBOS
  1549.       CHARACTER*(*) LINE
  1550.  
  1551.       COMMON /OPTSI/ MAXFWD, SPNULL, HEADER, FOLD, VERBOS
  1552. C---------------------------------------------------------
  1553. C    TOOLPACK/1    Release: 3.1
  1554. C---------------------------------------------------------
  1555. C
  1556. C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
  1557. C  PROVIDE PORTABLE RECORD BACKSPACING.
  1558. C
  1559. C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
  1560. C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
  1561. C             FROM A READS CALL FOR EACH FILE
  1562. C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
  1563. C             EACH FILE
  1564. C  SAVLIN     SAVED LINES FOR EACH FILE
  1565. C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
  1566. C  INFO(2..)  THE LINE NUMBER
  1567. C
  1568.       INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
  1569.       COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
  1570.       CHARACTER*134  SAVLIN(100, 2)
  1571.       COMMON /STACKC/ SAVLIN
  1572.       SAVE
  1573.  
  1574.       INTEGER       ZGETLN, ZLOWER, ZCCTOI
  1575.       CHARACTER     ZCITOC
  1576.       EXTERNAL      ERROR,ZCCTOI,ZCITOC,ZGETLN,ZLOWER
  1577.  
  1578.       IF(NXTOUT(FILE) .GE. NXTIN(FILE)) THEN
  1579.         STATUS = ZGETLN(SAVLIN(NXTLIN(FILE), FILE), FDS(FILE))
  1580.         IF(STATUS .EQ. -1) STATUS = -100
  1581.         INFO(1, NXTLIN(FILE), FILE) = STATUS
  1582.         INFO(2, NXTLIN(FILE), FILE) = NXTIN(FILE)
  1583.         NXTIN(FILE) = NXTIN(FILE) + 1
  1584.         NXTLIN(FILE) = NXTLIN(FILE) + 1
  1585.         IF(NXTLIN(FILE) .GT. 100) NXTLIN(FILE) = NXTLIN(FILE) - 100
  1586.       ENDIF
  1587.  
  1588.       NUMB = NXTOUT(FILE)
  1589.  
  1590.       DO 10 I = 1, 100
  1591.         POINT = NXTLIN(FILE) - I
  1592.         IF(POINT .LE. 0) POINT = POINT + 100
  1593.         IF(INFO(2, POINT, FILE) .EQ. NXTOUT(FILE)) THEN
  1594.           READS = INFO(1, POINT, FILE)
  1595.           IF(READS .EQ. -100) RETURN
  1596.           NXTOUT(FILE) = NXTOUT(FILE) + 1
  1597.           LINE = SAVLIN(POINT, FILE)
  1598.           IF(FOLD) THEN
  1599.             DO 20 J = 1, READS
  1600.               C = ZLOWER(ZCCTOI(LINE(J:J), C))
  1601.               LINE(J:J) = ZCITOC(C, LINE(J:J))
  1602.    20       CONTINUE
  1603.           ENDIF
  1604.           RETURN
  1605.         ENDIF
  1606.    10 CONTINUE
  1607.       CALL ERROR('READS: REQUESTED LINE UNAVAILABLE.')
  1608.  
  1609.       RETURN
  1610.       END
  1611. C------------------------------------------------------
  1612. C
  1613. C  BACKSPACE A FILE. MORE CORRECTLY MOVE TO A SPECIFIED
  1614. C  INPUT LINE.
  1615. C
  1616.       SUBROUTINE BSPACE(FILE, LINE)
  1617.  
  1618.       INTEGER FILE, LINE
  1619. C---------------------------------------------------------
  1620. C    TOOLPACK/1    Release: 3.1
  1621. C---------------------------------------------------------
  1622. C
  1623. C  READ BUFFERS FOR DATA COMPARE TOOL. THIS BUFFERING IS REQUIRED TO
  1624. C  PROVIDE PORTABLE RECORD BACKSPACING.
  1625. C
  1626. C  NXTIN      THE NEXT LINE NUMBER TO BE READ FROM THE FILES
  1627. C  NXTOUT     THE NEXT LINE NUMBER TO BE RETURNED TO THE PROGRAM
  1628. C             FROM A READS CALL FOR EACH FILE
  1629. C  NXTLIN     THE NEXT LINE TO BE USED IN THE BUFFER 'SAVLIN' FOR
  1630. C             EACH FILE
  1631. C  SAVLIN     SAVED LINES FOR EACH FILE
  1632. C  INFO(1..)  THE LENGTH OF THE LINE, OR E-O-F
  1633. C  INFO(2..)  THE LINE NUMBER
  1634. C
  1635.       INTEGER FDS(3), NXTIN(2), NXTOUT(2), NXTLIN(2), INFO(2, 100, 2)
  1636.       COMMON /STACKI/ FDS, NXTIN, NXTOUT, NXTLIN, INFO
  1637.       CHARACTER*134  SAVLIN(100, 2)
  1638.       COMMON /STACKC/ SAVLIN
  1639.       SAVE
  1640.  
  1641.       EXTERNAL ERROR
  1642.  
  1643.       IF(LINE .LE. 0) CALL ERROR('ILLEGAL BACKSPACE REQUESTED.')
  1644.       NXTOUT(FILE) = LINE
  1645.  
  1646.       RETURN
  1647.       END
  1648.